Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/SHDK_2/SHUTILPK.PAS

Pascal/Delphi Source File | 1992-04-30 | 23KB | 714 lines

{$I SHDEFINE.INC}

{$I SHUNITSW.INC}
{$O-}

{$D-,L-}

unit ShUtilPk;
{
                                ShUtilPk

                             A Utility Unit

                                   by

                              Bill Madison

                   W. G. Madison and Associates, Ltd.
                          13819 Shavano Downs
                            P.O. Box 780956
                       San Antonio, TX 78278-0956
                             [phone]
                             CIS 73240,342

                  Copyright 1991 Madison & Associates
                          All Rights Reserved

        This file may  be used and distributed  only in accord-
        ance with the provisions described on the title page of
                  the accompanying documentation file
                              SKYHAWK.DOC
}

Interface

Uses
  TpCrt,
  TpString,
  TpDos,
  Dos;

type
  CharSet       = set of char;
  DelimSetType  = set of char;

const
  DelimSet  : DelimSetType  = [#0..#32];

{*****************************************************************}
{ !!!!!!!!!!!!!!!!! NEVER MODIFY THESE VARIABLES !!!!!!!!!!!!!!!!!}
{*****************************************************************}
Var
  StartingMode : Byte;
{Initial video mode of the system (Mono, CO80, BW40, ...)}

  StartingAttr : Byte;
{Initial video attribute of the system}

{*****************************************************************}
{*****************************************************************}

function BetwS(Lower, Item, Upper  : LongInt) : boolean;
{Performs a SIGNED test of the condition that Lower <= Item <= Upper,
 returning TRUE if and only if the condition is met. Lower, Item, and
 Upper can be any combination of 1, 2, and 4-byte entities.}

{**********************************************************************}

function BetwU(Lower, Item, Upper  : LongInt) : boolean;
{Performs an UNSIGNED test of the condition that Lower <= Item <= Upper,
 returning TRUE if and only if the condition is met. Lower, Item, and
 Upper can be any combination of 1, 2, and 4-byte entities.}

{**********************************************************************}

Function StarString(Pattern, Target : String) : Boolean;
{This function performs a generalization of the wildcard string
 matching usually performed by DOS. A '*' wild card can be placed
 anywhere within the pattern string, and will represent its usual
 'zero or more of any characters'. Scanning will not be terminated
 at that point, however, but will continue. Thus, '*B*EFG' will match
 'ABCDEFG', but '*B*EGF' will not. Similarly, '*ABC*' will match, but
 '*ABC' will not.}

{**********************************************************************}

Function WhoAmI : String;
{Returns the fully qualified path to the currently executing file.
 *** DOS 3.x or above, ONLY ***}

{**********************************************************************}

function SearchEnvironment(Code : String) : String;
{Searches the environment space for "CODE" and returns the corresponding
 string.}

{**********************************************************************}

Function LoWord(LI : LongInt) : Word;
{Returns the low order word of a LongInt.}

{**********************************************************************}

Function HiWord(LI : LongInt) : Word;
{Returns the high order word of a LongInt.}

{**********************************************************************}

Function LI(Ilo, Ihi : Word) : LongInt;
{Converts two Word vbls to a LongInt}

{**********************************************************************}

Function HEX(A : LongInt) : String;
{Converts a byte vbl into a string correspnoding to the hex value.}
{NOTE: The parameter A may be of any Integer type (ShortInt, Byte,
 Integer, Word, or LongInt}
{HEX will return either a 2, 4, or 8 character string, depending on
 whether the actual value of the parameter is representable as a
                          1 byte value (ShortInt, Byte)
                          2 byte value (Integer, Word)
                          4 byte value (LongInt)
 Note that a negative value will always be returned as an 8 character
 string.}

{**********************************************************************}

Function Pmod(x, modulus : LongInt) : LongInt;
{Returns the mod as a positive number, regardless of the sign of X.
 Recall that, e.g., -1 is congruent to (modulus-1). Thus, for example,
 Pmod(-2, 7) will return 5 as the function value.}

{**********************************************************************}

  Procedure RepAll(S1, FS, SS : string; var S2 : string);
  {In string S1 replace all occurrences of FS with SS, giving S2}

  function RepAllF(S1, FS, SS : string) : string;

{**********************************************************************}

  Procedure DelAll(S1, DS : string; var S2 : string);
  {In string S1 delete all occurrences of DS, giving S2}

  function DelAllF(S1, DS : string) : string;

{**********************************************************************}

function PosSet(A : CharSet; S : string) : byte;
{Returns the position of the first occurrance of any member of A in S}

{**********************************************************************}

  Procedure GetNext(var S1, S2 : String);
  {Extracts the next substring from S1 delimited by a member of DelimSet
  and returns it in S2. S1 is returned with the sub-string stripped off.
  If S1 is empty on entry, both S1 and S2 will be empty on return.}

  function GetNextF(var S1 : string) : string;

{**********************************************************************}


function UniqueFileName(Path : string; AddExt : boolean) : string;
{Returns a file name which will be unique in the directory specified
 by PATH. On return, the file name will be appended to PATH. If AddExt
 is TRUE, an extension of .$$$ will be appended, else only the file name
 will be returned.}

{**********************************************************************}


Implementation
{------------}

var
  Regs : Registers;
  XY   : WindowCoordinates;

{**********************************************************}

function BetwS(Lower, Item, Upper  : LongInt) : boolean;
{Performs a SIGNED test of the condition that Lower <= Item <= Upper,
 returning TRUE if and only if the condition is met. Lower, Item, and
 Upper can be any combination of 1, 2, and 4-byte entities.}
  begin
    BetwS := (Item >= Lower) and (Item <= Upper);
    end;

{**********************************************************}

function BetwU(Lower, Item, Upper  : LongInt) : boolean;
{Performs an UNSIGNED test of the condition that Lower <= Item <= Upper,
 returning TRUE if and only if the condition is met. Lower, Item, and
 Upper can be any combination of 1, 2, and 4-byte entities.}
  const
  {In the following table, columns represent hi-word states,
   rows represent lo-word states.

      1. a < b, b < c     4. a = b, b < c     7. a > b, b < c
      2.        b = c     5.        b = c     8.        b = c
      3.        b > c     6.        b > c     9.        b > c }

    ST  : array[1..9,1..9] of boolean =
      ((  true,  true, false,  true,  true, false, false, false, false),
       (  true,  true, false,  true,  true, false, false, false, false),
       (  true, false, false,  true, false, false, false, false, false),
       (  true,  true, false,  true,  true, false, false, false, false),
       (  true,  true, false,  true,  true, false, false, false, false),
       (  true, false, false,  true, false, false, false, false, false),
       (  true,  true, false, false, false, false, false, false, false),
       (  true,  true, false, false, false, false, false, false, false),
       (  true, false, false, false, false, false, false, false, false));

  type
    WO  = ( HW, LW );
    X   = record
            case byte of
              1 : (L : LongInt);
              2 : (W : array[ WO ] of word);
              end;
    LT  = 1..3;
  var
    HiState,
    LoState   : byte;
  function LEG(A, B : word) : LT;
  {Returns 1, 2, 3 as A is <, =, > B}
    begin
      if A < B then
        LEG := 1
      else if A = B then
          LEG := 2
        else
          LEG := 3;
      end;
  begin
    HiState := (3 * LEG(X(Lower).W[HW], X(Item).W[HW]) - 2) +
               (LEG(X(Item).W[HW], X(Upper).W[HW]) - 1);
    LoState := (3 * LEG(X(Lower).W[LW], X(Item).W[LW]) - 2) +
               (LEG(X(Item).W[LW], X(Upper).W[LW]) - 1);
    BetwU := ST[HiState, LoState];
    end;

{**********************************************************}

Function StarString;
{StarString is a Boolean function which returns True if a pattern
 string possibly containing one or more '*' wild cards matches a
 target. It works by repeatedly extracting maximum length sub-
 strings not containing a * from Pattern, determining if that sub-
 string exists in Target, and, if so, deleting from Target the first
 character through the end of the partial pattern. A final test is
 made on the residual portion of each to determine the final truth
 value of the function. Character wild cards ('?') are handled by
 substituting characters 1-for-1 from the target string into the
 earliest possible match and proceeding as if they were non-existant.
 The function will terminate as soon as the truth value can be
 determined, so that no time is wasted in execution.}
  var
    Index   : Byte;
    TrialB  : String;

  procedure ReplQ(var Pattern1 : String; Target1 : String);
  {Replaces all occurrences of '?' in Pattern1 with the corresponding
   character from Target1. If Target1[0] < Pattern1[0], any '?' occurring
   in the tail will not be effected.}
    var
      T1 : Byte;
    begin
      T1 := Pos('?', Pattern1);
      While (T1 <> 0) and (T1 <= Byte(Pattern1[0])) do begin
        Pattern1[T1] := Target1[T1];
        T1 := Pos('?', Pattern1);
        end;
      end; {ReplQ}

  procedure Split(Instr : String; Ch : Char; var Before, After : String;
                  var Index : Byte);
  {Splits Instr on the first occurrence of the character Ch. The products
   of the split are returned in Before and After. Ch itself is discarded.
   Index returns the character position in Instr at which the split
   occurred. (0 means no split)}
    begin
     Index := Pos(Ch, Instr);
     Before := Copy(Instr, 1, Index - 1);
     Delete(Instr, 1, Index);
     After := Instr;
     end; {Split}

  procedure CountOccur(PatStr, InStr : String; var Count : Byte);
  {Counts the number of occurrences of PatStr in Instr and returns the
   count in Count}
    var
      T1  : Byte;
    begin
      Count := 0;
      T1 := Pos(PatStr, InStr);
      While T1 <> 0 do begin
        Inc(Count);
        Delete(Instr, 1, T1);
        T1 := Pos(PatStr, Instr);
        end;
      end; {CountOccur}

  procedure BuildMatch(var Pattern1, Target1 : String; var Index1 : Byte);
  {If possible, constructs the version of Pattern1 which matches the
   earliest substring of Target1 by eliminating character wild cards.
   The position is returned in Index1}
    var
      Pat1  : String;
      T1,           {Pointer within Target1 to start of trial match }
      T2,           {FOR loop index for character replacement       }
      T3,           {Number of character wild cards in Pat1         }
      T4    : Byte; {Position of the T3th character wild card       }
    begin
      If Pattern1 = '' then exit;
      If Pos('?', Pattern1) = 0 then begin
        Index1 := Pos(Pattern1, Target1);
        exit;
        end;
      T1 := 0;
      Pat1 := Pattern1;
      CountOccur('?', Pat1, T3);
      Index1 := Pos(Pat1, Target1);
      While ((T1 + Byte(Pat1[0])) <= Byte(Target1[0])) and
             (Index1 = 0) do begin
        For T2 := 1 to T3 do begin
          T4 := Pos('?',Pat1);
          Pat1[T4] := Target1[T1+T4];
          end; {For}
        Index1 := Pos(Pat1, Target1);
        If Index1 = 0 then
          Pat1 := Pattern1
        else
          Pattern1 := Pat1;
        Inc(T1);
        end; {While}
      end; {BuildMatch}

  begin {StarString}

    {First, take care of all the special cases}

    While Pos('**', Pattern) <> 0 do
      Delete(Pattern, Pos('**', Pattern), 1);

    If (Byte(Pattern[0]) = 0) or           {No pattern string  }
       (Byte( Target[0]) = 0) then begin   {or no target string}
      StarString := False;
      Exit;
      end;

    If Pattern[1] = '?' then
      Pattern[1] := Target[1];

    If Pos('*', Pattern) = 0 then begin    {No wild cards, so }
      ReplQ(Pattern, Target);              {Quick result known}
      StarString := (Pattern = Target);
      Exit;
      end;

    Split(Pattern, '*', TrialB, Pattern, Index);
    BuildMatch(TrialB, Target, Index);
    If Index <> 1 then begin               {No match possible }
      StarString := False;
      exit;
      end;

    {End of special cases. Proceed with normal processing}

    Pattern := TrialB + '*' + Pattern;     {Possible match, so  }
                                           {reconstruct Pattern }
                                           {and proceed         }

    While (Pos('*', Pattern) <> 0) do begin  {Still more wild cards}
      Split(Pattern, '*', TrialB, Pattern, Index);
                                             {Disect the pattern   }

      {TrialB now contains that portion to the left of the wildcard,
       and Pattern contains what was to the right. The wild card
       itself has been discarded.}

      {From TrialB build the best possible match to Target, getting
       rid of character wild cards. Put the expanded string back into
       TrialB for further processing.}

      BuildMatch(TrialB, Target, Index);     {Try to find a match  }
                                             { and set the Index   }

      If Index = 0 then begin                {No match is possible }
        StarString := False;
        exit;
        end
      else begin                              {Still possible match}
        Delete(Target, 1, Index + Byte(TrialB[0]) - 1);
        end;                                  {Strip off past the  }
      end; {While}                            { last left pattern  }
                                              { and try again      }
      If Byte(Pattern[0]) = 0 then     {'*' as last character of Pattern}
        StarString := True             { so we know there is a match.   }

      else begin        { Make sure we are looking at *last* occurrance }
                        {                          of Pattern in Target }
        Index := Pos(Pattern, Target);
        TrialB := Target;                     { Save the current target }
        While Index <> 0 do begin
          Delete(Target, 1, Index + Byte(Pattern[0]) - 1);
                                        { Delete through end of Pattern }
          Index := Pos(Pattern, Target);
          If Index <> 0 then TrialB := Target;    { Save the new target }
          end;

        { TrialB now contains the maximum length substring of Target    }
        { which contains the *last* occurrance of Pattern.              }

        BuildMatch(Pattern, TrialB, Index);
        If Index = 0 then
          StarString := False
        else
          StarString := ((Index + Byte(Pattern[0]) - 1) = Byte(TrialB[0]));
        end;
    end; {Function StarString}

{***************************************************************}

function WhoAmI;
var
  s, o  : integer;
  c     : string;
begin
  s := memw[PrefixSeg:$2c];    {the segment address of the start of   }
  o := 0;                      { the environment area at PrefixSeg:$2c}
  while memw[s:o] <> 0 do      {search for end of environment         }
    o := succ(o);              {  which is marked by two 0 bytes      }
  o := o + 4;                  {skip across word count       }
  c := '';
  repeat
    c := c + chr(mem[s:o]);    {transfer fully qualified path       }
    o := succ(o);              {  as a legitimate TurboPASCAL string}
    until mem[s:o] = 0;
  WhoAmI := c;
  end;

{**********************************************************************}

function searchenvironment;
  var
   x,y   : integer;
   cs    : string;
  begin
   x := memw[prefixseg:$2C];
   y := 0;
   while memw[x:y] <> 0 do begin
    if chr(mem[x:y]) = code[1] then begin
     cs := '';
     repeat                           {copy up to the '='}
      cs := cs + chr(mem[x:y]);
      y := y + 1
      until chr(mem[x:y]) = '=';
     if cs = code then begin          {got a match, so}
      y := y + 1;                       {space across the '='}
      cs := '';
      repeat                            {and copy what's on the other side}
       cs := cs + chr(mem[x:y]);
       y := y + 1
       until mem[x:y] = 0;
      searchenvironment := cs;          {and that's the function value..}
      exit                              {so set it and bail out}
      end {if cs = code}
     end {chr(mem[x:y]) = code[1]}
    else                               {no match, so}
     repeat                            {just find the end of the string}
      y := y + 1
      until mem[x:y] = 0;
    y := y + 1;                      {space across string delimiter}
    end; {while}
    searchenvironment := '';
   end; {of searchenvironment}

{**********************************************************}

Function LoWord;
  type
    XT = array[1..2] of Word;
  var
    X : XT absolute LI;
  begin
    LoWord := X[1];
    end;

{**********************************************************************}

Function HiWord;
  type
    XT = array[1..2] of Word;
  var
    X : XT absolute LI;
  begin
    HiWord := X[2];
    end;

{**********************************************************************}

Function LI;
{Converts two Word vbls to a LongInt}
type
  LItype = record
             case Integer of
               1 : (IT : array[1..2] of Integer);
               2 : (LIT: LongInt);
             end;
var
  X : LItype;
begin
  X.IT[1] := Ilo;
  X.IT[2] := Ihi;
  LI := X.LIT;
  end;

{**********************************************************************}

Function HEX;
  Type
    HexByte = record
                case Byte of
                  1 : (LI : LongInt);
                  2 : (BY : array[0..3] of Byte);
                  3 : (Ts : array[0..1] of Word);
                end;
  Const
    B : Array[0..15] of Char =
             ('0','1','2','3','4','5','6','7','8','9',
              'A','B','C','D','E','F');
  Var
    S1 : String;
    T1,
    T2 : Byte;
    HB : HexByte absolute A;
  Begin
    Case HB.Ts[1] of
      0 :  begin
             T2 := 1;           {At most 2 byte vbl}
             Case HB.BY[1] of
               0 : T2 := 0;     {It's a Byte}
               end;
             end;
      else T2 := 3;
      end;
    S1 := '';
    For T1 := T2 downto 0 do
      S1 := S1 + B[HB.BY[T1] shr 4] + B[HB.BY[T1] and $0F];
    HEX := S1;
    end;

{**********************************************************************}

function Pmod;
begin
  Pmod := ((x mod modulus) + modulus) mod modulus;
  end;

{**********************************************************}

  Procedure RepAll(S1, FS, SS : string; var S2 : string);
  {In string S1 replace all occurrences of FS with SS}
    var
      T1 : Integer;
      S3  : string;
    begin
      S2 := '';
      while Pos(FS, S1) <> 0 do begin
        T1 := Pos(FS, S1);
        S2 := S2 + copy(S1, 1, pred(T1)) + SS;
        delete(S1, 1, pred(T1) + Length(FS));
        end; {while}
      S2 := S2 + S1;
      end; {RepAll}

  function RepAllF(S1, FS, SS : string) : string;
    var
      S2  : string;
    begin
      RepAll(S1, FS, SS, S2);
      RepAllF := S2;
      end; {RepAllF}

{**********************************************************}

  Procedure DelAll(S1, DS : string; var S2 : string);
  {In string S1 delete all occurrences of DS}
    begin
      RepAll(S1, DS, '', S2);
      end;

  function DelAllF(S1, DS : string) : string;
    begin
      DelAllF := RepAllF(S1, DS, '');
      end; {DelAllF}

{**********************************************************}

function PosSet(A : CharSet; S : string) : byte;
  var
    T1  : byte;
  begin
    T1 := 1;
    while (not (S[T1] in A)) and (T1 < Length(S)) do
      inc(T1);
    if S[T1] in A then
      PosSet := T1
    else
      PosSet := 0;
    end; {PosSet}

  function TrimLeadSet(S : string; CS : CharSet) : string;
    var
      L : byte;
    begin
      L := 1;
      while (S[L] in CS) and (L <= byte(S[0])) do
        inc(L);
      if L = 0 then
        TrimLeadSet := ''
      else
        TrimLeadSet := Copy(S, L, 255);
      end; {TrimLeadSet}

  function TrimTrailSet(S : string; CS : CharSet) : string;
    begin
      while (S[byte(S[0])] in CS) and (byte(S[0]) > 0) do
        dec(S[0]);
      TrimTrailSet := S;
      end; {TrimTrailSet}

  function TrimSet(S : string; CS : CharSet) : string;
    begin
      TrimSet := TrimTrailSet(TrimLeadSet(S, CS), CS);
      end; {TrimSet}

  Procedure GetNext(var S1, S2 : String);
  {Extracts the next space-delimited string from S1 and returns it
  in S2. S1 is returned with the sub-string stripped off.
  If S1 is empty on entry, both S1 and S2 will be empty on return.}

  var
    T1 : Integer;
  begin {GetNext}
    If Length(S1) = 0 then begin
      S2[0] := chr(0);
      Exit
      end;
    S1 := TrimSet(S1, DelimSet);     {Strip leading and trailing blanks}
    If Length(S1) = 0 then
      S2[0] := chr(0)
    else
      If PosSet(DelimSet, S1) <> 0 then begin
        T1 := PosSet(DelimSet, S1);
        S2 := Copy(S1, 1, Pred(T1));
        S1 := Copy(S1, T1, Length(S1) - Pred(T1));
        end
      else begin
        S2 := S1;
        S1 := '';
        end;
    end; {GetNext}

  function GetNextF(var S1 : string) : string;
  var
    S2 : string;
  begin
    GetNext(S1, S2);
    GetNextF := S2;
    end; {GetNextF}

{**********************************************************}


function UniqueFileName(Path : string; AddExt : boolean) : string;
  var
    FN :  record
            case integer of
              1 : (LI : LongInt);
              2 : (WD : array[1..2] of word);
              end;
    R  :  Registers;
    S  :  string;

  begin
    R.AH := $2C;
    MsDos(R);
    FN.WD[1] := R.CX;
    FN.WD[2] := R.DX;
    repeat
      Inc(FN.LI);
      S := Path + HexL(FN.LI);
      if AddExt then S := S + '.$$$';
      until not ExistFile(S);
    UniqueFileName := S
    end;




{**********************************************************}

begin {Initialization section}
  StartingMode := Mem[0:$449];
  With Regs do begin
    AH := 8;
    Intr( $10, Regs );
    StartingAttr := AH;
    end;
  end.